perm filename BITLAB[FOO,LMM] blob
sn#094032 filedate 1974-03-25 generic text, type T, neo UTF8
(FILECREATED "25-MAR-74 19:47:19" BITLABELER
changes to: BITLABELERVARS
previous date: "25-MAR-74 01:55:13")
(LISPXPRINT (QUOTE BITLABELERVARS) T)
(RPAQQ BITLABELERVARS ((RECORDS* PERMUTATION PERMCYCLE) (COMPROP* MACRO 2TO
LOG2 CONTAINED ELTLESSP TWICE NEXTSMALLESTELT DISJOINTDIFF ALLLARGERELTS
LARGESTELT MAKESET DIFF1 ELEMENTOF ADDELT DIFF EMPTY UNIONSET INTERSECT DISJOINT
NULLSET EQSET SIZE FIRST REST) (FNS LISTCYCLES ELTTIMES PERMTIMES TAKEN GCD
RELATIVELYPRIME LCM PERMCYCLEINDEX1 BINARY.LSTG LST.BINARYG BINARY.LST
LST.BINARY LOG2 CONTAINED LISTELT DM DIFF SIZE FIRST REST MAX LABELGRAPH GG2
GG1 GROUPGENBY PR1 PRISM DIHEDRAL REFLECTION R1 SN ID1 IDENTITY DP2 DP1
DIRECTPRODUCT CYC1 CYCLICGENBY PTIMES XTIMES XTIMES1 D2 D1 MAPCONS IMAGES
MAPPINGS CHECK INSERTCL DIFFCL SUBSETS PCYCLEINDEX CYCLEINDEX LFROMCL POLYA
INSERT ORDERED SLTPSANDPINVS) (FNS MLG ORBIT1 REDUCEGROUP COMB MANYLABELGRAPHTOP
MANYLABELGRAPH LABELCLASS LABELGENCLASS LABELORBITS LO1 LOADD ORBITS CANONICAL
SLTPS) (VARS (INPUTMODE (QUOTE FUNCTION)))))
(PROGN (QUOTE JUSTEVALUATE) (RECORD PERMUTATION (CYCLESOF ORDEROF . POWERSOF))
(RECORD PERMCYCLE (SIZEOF . SETOF)))
(DEFLIST(QUOTE(
(2TO ((N) (LLSH 1 (SUB1 N))))
(LOG2 NIL)
(CONTAINED ((A B) (ZEROP (LOC (ASSEMBLE NIL (CQ (VAG A)) (PUSHN) (CQ (VAG
B)) (POP NP , 10) (XOR 1 , 10) (AND 1 , 10))))))
(ELTLESSP ((X Y) (IGREATERP X Y)))
(TWICE ((X) (LLSH X 1)))
(NEXTSMALLESTELT ((X) (TWICE X)))
(DISJOINTDIFF ((X Y) (LOGXOR X Y)))
(ALLLARGERELTS ((X) (SUB1 X)))
(LARGESTELT (NIL 1))
(MAKESET (X (CONS (QUOTE LOGOR) X)))
(DIFF1 ((A B) (DIFF A B)))
(ELEMENTOF ((X A) (CONTAINED X A)))
(ADDELT ((X A) (UNION X A)))
(DIFF ((A B) (LOC (ASSEMBLE NIL (CQ (VAG A)) (PUSHN) (CQ (VAG B)) (POP NP
, 2) (XOR 1 , 2) (AND 1 , 2)))))
(EMPTY ((X) (ZEROP X)))
(UNIONSET ((A B) (LOGOR A B)))
(INTERSECT ((A B) (LOGAND A B)))
(DISJOINT ((A B) (EMPTY (INTERSECT A B))))
(NULLSET (NIL 0))
(EQSET ((X Y) (EQP X Y)))
(SIZE ((A) (LOC (ASSEMBLE NIL (CQ (VAG A)) (MOVE 2 , 1) (HRRZI 1 , 0) (JUMPE
2 , RET) LP (ADDI 1 , 1) (MOVE 3 , 2) (SUBI 3 , 1) (AND 2 , 3) (JUMPN 2 ,
LP) RET))))
(FIRST ((X) (LOC (ASSEMBLE NIL (CQ (VAG X)) (HRREI 2 , -1) (ADD 2 , 1) (XOR
2 , 1) (AND 1 , 2)))))
(REST ((X) (LOC (ASSEMBLE NIL (CQ (VAG X)) (HRREI 2 , -1) (ADD 2 , 1) (AND
1 , 2)))))
))(QUOTE MACRO)(QUOTE JUSTEVALUATE))
(DEFINEQ
(LISTCYCLES
[LAMBDA (PERM)
(* RETURNS THE LIST OF CYCLES OF PERM, WHERE CYCLE IS A LIST
OF ELEMENTS)
(PROG (LS X PX)
(SETQ X (CAR PERM))
(SETQ PX X)
L1 (SETQ LS (CONS [PROG ((RSLT))
LP (SETQ PX (ELTTIMES PX PERM))
(SETQ RSLT (CONS PX RSLT))
(COND
((EQ PX X)
(RETURN RSLT))
(T (GO LP]
LS))
[COND
((FOR OLD X IN PERM ALWAYS (THEREIS CYCLE IN LS
SUCHTHAT (MEMB X CYCLE)))
(RETURN (FOR X IN LS WHEN (CDR X) COLLECT X]
(SETQ PX X)
(GO L1])
(ELTTIMES
[LAMBDA (X P)
(CAR (FNTH P X])
(PERMTIMES
[LAMBDA (P1 P2)
(FOR X IN P1 COLLECT (ELTTIMES X P2])
(TAKEN
[LAMBDA (N I)
(bind RESULT←1 for J from 1 to I do (SETQ RESULT (IQUOTIENT (ITIMES RESULT
N)
J))
(SETQ N (SUB1 N))
finally (RETURN RESULT])
(GCD
[LAMBDA (N1 N2)
(COND
((EQ 0 (SETQ N1 (IREMAINDER N1 N2)))
N2)
(T (GCD N2 N1])
(RELATIVELYPRIME
[LAMBDA (N1 N2)
(EQ 1 (GCD N1 N2])
(LCM
[LAMBDA (N1 N2)
(IQUOTIENT (ITIMES N1 N2)
(GCD N1 N2])
(PERMCYCLEINDEX1
[LAMBDA (PERM)
(FOR CYCLE IN (fetch CYCLESOF of PERM) COLLECT (fetch SIZEOF of CYCLE])
(BINARY.LSTG
[LAMBDA (GROUP)
(FOR PERM IN GROUP COLLECT (FOR X IN (CAR (fetch POWERSOF of PERM))
COLLECT (LOG2 X])
(LST.BINARYG
[LAMBDA (GROUP)
(PROG (RESULTS CYCLES ORDERS P2 ORDER)
[FOR
PERM IN GROUP
DO
(COND
((SETQ CYCLES (LISTCYCLES PERM))
(SETQ ORDER 1)
[FOR CYCLE IN CYCLES DO (SETQ ORDER (LCM ORDER (LENGTH CYCLE]
(SETQ ORDERS (CONS 1 (FOR I FROM 10 TO (LLSH ORDER -1)
WHEN (RELATIVELYPRIME I ORDER)
COLLECT I)))
(SETQ P2 PERM)
(SETQ RESULTS
(CONS
[CREATE
PERMUTATION ORDEROF ←(COND
((EQ ORDER 10)
NIL)
(T ORDERS))
CYCLESOF ←[SORT (FOR CYCLE IN CYCLES
COLLECT (CREATE PERMCYCLE SIZEOF ←(
LENGTH CYCLE)
SETOF ←(LST.BINARY
CYCLE)))
(FUNCTION (LAMBDA (X Y)
(ILESSP (fetch SIZEOF of X)
(fetch SIZEOF of Y]
POWERSOF ←(CONS
(MAPCAR PERM (QUOTE LST.BINARY))
(FOR I FROM 10
TO (FOR I IN ORDERS MAXIMUM I)
JOIN (PROGN (SETQ P2 (PERMTIMES PERM P2))
(COND
((MEMB I ORDERS)
(LIST (MAPCAR P2 (QUOTE LST.BINARY]
RESULTS]
(RETURN RESULTS])
(BINARY.LST
[LAMBDA (L)
(COND
((NULL L)
NIL)
((NLISTP L)
(FOR X IN (LISTELT L) COLLECT (LOG2 X)))
(T (MAPCAR L (QUOTE BINARY.LST])
(LST.BINARY
[LAMBDA (L)
(COND
((NULL L)
NIL)
((NLISTP L)
(2TO L))
((NLISTP (CAR L))
(bind RSLT←0 for X in L do (SETQ RSLT (UNIONSET RSLT (LST.BINARY X)))
finally (RETURN RSLT)))
(T (MAPCAR L (QUOTE LST.BINARY])
(LOG2
[LAMBDA (X)
(PROG ((I 0))
LP [COND
((ZEROP X)
(RETURN I))
(T (SETQ X (LLSH X -1]
(SETQ I (ADD1 I))
(GO LP])
(CONTAINED
[LAMBDA (A B)
(ZEROP (LOGAND A (LOGXOR A B])
(LISTELT
[LAMBDA (NODES)
(PROG (FN RSLT)
LP [COND
((EMPTY NODES)
(RETURN (DREVERSE RSLT]
(SETQ RSLT (CONS (FIRST NODES)
RSLT))
(SETQ NODES (REST NODES))
(GO LP])
(DM
[NLAMBDA L
[COND
((LISTP (CAR L))
(ERROR (CAR L)
(QUOTE "NOT ATOM"]
[RPLACA (QUOTE CHANGEDPROPLST)
(CONS (CAR L)
(CAR (QUOTE CHANGEDPROPLST]
(AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA)
CHANGEDPROPLST)))
(/PUT (CAR L)
(QUOTE MACRO)
(CDR L))
(ADDSPELL (CAR L))
(CAR L])
(DIFF
[LAMBDA (A B)
(LOGAND A (LOGXOR B A])
(SIZE
[LAMBDA (X)
(ADD1 (WHILE [NOT (EMPTY (SETQ X (REST X] SUM 1])
(FIRST
[LAMBDA (X)
(LOGAND X (LOGXOR X (SUB1 X])
(REST
[LAMBDA (X)
(LOGAND X (SUB1 X])
(MAX
[LAMBDA (I J)
(COND
((IGREATERP I J)
I)
(T J])
(LABELGRAPH
[LAMBDA (NODES GROUP NUMBER)
(COND
((NULL GROUP)
(FOR X IN (COMB NODES NUMBER) COLLECT (CONS X NIL)))
[(IGREATERP (ITIMES 10 NUMBER)
(SIZE NODES))
(FOR X IN (LABELGRAPH NODES GROUP (IDIFFERENCE (SIZE NODES)
NUMBER))
RCOLLECT (CONS (DIFF NODES (CAR X))
(CDR X]
((ZEROP NUMBER)
(LIST (CONS (NULLSET)
GROUP)))
(T (PROG (FC RESULT)
[COND
((EQSET NODES (SETQ FC (ORBIT1 NODES GROUP)))
(RETURN (LABELCLASS NODES GROUP NUMBER]
(SETQ NODES (DIFF NODES FC))
(RETURN (FOR X FROM (IMAX 0 (IDIFFERENCE NUMBER (SIZE NODES)))
TO (IMIN NUMBER (SIZE FC)) FOR LBL1
IN (LABELCLASS FC GROUP X) FOR LBL2
IN (LABELGRAPH NODES (CDR LBL1)
(IDIFFERENCE NUMBER X))
RCOLLECT (CONS (UNIONSET (CAR LBL2)
(CAR LBL1))
(CADR LBL2])
(GG2
[LAMBDA (G1*2 G1 G2 G)
(COND
((MEMBER G1*2 G)
(GG1 G1 (CDR G2)
G))
(T (PROGN (RPLACD G2 (CONS G1*2 (CDR G2)))
(GG1 G1 (CDR G2)
G])
(GG1
[LAMBDA (G1 G2 G)
(COND
((NULL G1)
G)
((NULL G2)
(GG1 (CDR G1)
(CDR G1)
G))
(T (GG2 (PTIMES (CAR G1)
(CAR G2))
G1 G2 G])
(GROUPGENBY
[LAMBDA (G)
(GG1 G G G])
(PR1
[LAMBDA (N P)
(MAPCAR N (FUNCTION (LAMBDA (X)
(PTIMES X (PTIMES P (PTIMES X P])
(PRISM
[LAMBDA (A B N)
(DIRECTPRODUCT (LIST (R1 A B N)
(IDENTITY N))
(PR1 (DIHEDRAL A N)
(R1 A B N])
(DIHEDRAL
[LAMBDA (A N)
(DIRECTPRODUCT (LIST (REFLECTION A N)
(IDENTITY N))
(CYCLICGENBY (D2 A N])
(REFLECTION
[LAMBDA (A N)
(R1 A NIL N])
(R1
[LAMBDA (A B N)
(COND
((IGREATERP (LENGTH A)
(ADD1 (LENGTH B)))
(R1 (CDR A)
(CONS (CAR A)
B)
N))
((NULL B)
(IDENTITY N))
(T (PTIMES (CADR (SN (LIST (IMIN (CAR A)
(CAR B))
(IMAX (CAR A)
(CAR B)))
N))
(R1 (CDR A)
(CDR B)
N])
(SN
[LAMBDA (A N)
(MAPPINGS A A (IDENTITY N])
(ID1
[LAMBDA (I N)
(COND
((IGREATERP I N)
NIL)
(T (CONS I (ID1 (ADD1 I)
N])
(IDENTITY
[LAMBDA (N)
(ID1 1 N])
(DP2
[LAMBDA (PCG P G PRD)
(COND
((MEMBER PCG PRD)
(DP1 P (CDR G)
PRD))
(T (DP1 P (CDR G)
(CONS PCG PRD])
(DP1
[LAMBDA (P G PRD)
(COND
((NULL G)
PRD)
(T (DP2 (PTIMES P (CAR G))
P G PRD])
(DIRECTPRODUCT
[LAMBDA (G1 G2)
(COND
((NULL G1)
NIL)
(T (DP1 (CAR G1)
G2
(DIRECTPRODUCT (CDR G1)
G2])
(CYC1
[LAMBDA (P1 P2)
(COND
((EQUAL P1 P2)
(LIST P1))
(T (CONS P2 (CYC1 P1 (PTIMES P1 P2])
(CYCLICGENBY
[LAMBDA (P)
(CYC1 P (PTIMES P P])
(PTIMES
[LAMBDA (P1 P2)
(MAPCAR P1 (FUNCTION (LAMBDA (Z)
(XTIMES Z P2])
(XTIMES
[LAMBDA (X P)
(XTIMES1 X 1 P])
(XTIMES1
[LAMBDA (X I P)
(COND
((EQ X I)
(CAR P))
(T (XTIMES1 X (ADD1 I)
(CDR P])
(D2
[LAMBDA (A N)
(D1 1 N A A])
(D1
[LAMBDA (I N Y A)
(COND
((IGREATERP I N)
NIL)
((NULL Y)
(CONS I (D1 (ADD1 I)
N A A)))
((NOT (EQ I (CAR Y)))
(D1 I N (CDR Y)
A))
((CDR Y)
(CONS (CADR Y)
(D1 (ADD1 I)
N A A)))
(T (CONS (CAR A)
(D1 (ADD1 I)
N A A])
(MAPCONS
[LAMBDA (X L)
(MAPCAR L (FUNCTION (LAMBDA (Y)
(CONS X Y])
(IMAGES
[LAMBDA (A2A A2B A B)
(COND
((NULL A2A)
NIL)
(T (APPEND (MAPCONS (CAR A2A)
(MAPPINGS (CDR A)
(APPEND (CDR A2A)
A2B)
(CDR B)))
(IMAGES (CDR A2A)
(CONS (CAR A2A)
A2B)
A B])
(MAPPINGS
[LAMBDA (A A2 B)
(COND
((NULL A)
(LIST B))
((NULL B)
NIL)
[(NOT (MEMBER (CAR B)
A))
(MAPCONS (CAR B)
(MAPPINGS A A2 (CDR B]
(T (IMAGES A2 NIL A B])
(CHECK
[LAMBDA (FN LEXP)
(PROG (NF)
(SETQ NF (PACK (LIST FN @ *CHK)))
[COND
[(GET (CDR FN)@ SUBR)
(PROGN (PUT NF @(GET (CDR FN)@ SUBR)
SUBR)
(PROG1 NIL (REMPROP FN @ SUBR]
((GET (CDR FN)@ EXPR)
(PUT NF @(GET (CDR FN)@ EXPR)
EXPR))
(T (RETURN @(? FN NOT EXPR OR SUBR]
(DEFINE @((? FN (LAMBDA ?
(CADR LEXP)
(PROG (CNT RES)
(SETQ RES ? (CONS NF (CADR LEXP)))
(SETQ CNT ? (CADDR LEXP))
(COND
((EQUAL (LENGTH RES)
CNT)
(RETURN RES)))
(PRINT (QUOTE (ERROR IN:)))
(PRIN1 (QUOTE ? FN))
(PRINT ? (CONS @ LIST (CADR LEXP)))
(PRIN1 (QUOTE "PREDICTED NUMBER="))
(PRINT CNT)
(PRIN1 (QUOTE "ACTUAL NUMBER="))
(PRINT (LENGTH RES))
(PRIN1 (QUOTE "VALUE IS="))
(PRINT RES)
(EXITERR T)
(ERROR (QUOTE ? FN])
(INSERTCL
[LAMBDA (NUMBER ELEMENT OLDCL ORDERF)
(COND
((OR (NULL OLDCL)
(APPLY* ORDERF ELEMENT (CAAR OLDCL)))
(CONS (CONS ELEMENT NUMBER)
OLDCL))
((NOT (APPLY* ORDERF (CAAR OLDCL)
ELEMENT))
(RPLACD (CAR OLDCL)
(IPLUS (CDAR OLDCL)
NUMBER))
OLDCL)
(T [FOR CL ON OLDCL DO (COND
[(OR (NULL (CDR CL))
(APPLY* ORDERF ELEMENT (CAADR CL)))
(RETURN (RPLACD CL (CONS (CONS ELEMENT NUMBER)
(CDR CL]
((NOT (APPLY* ORDERF ELEMENT (CAADR CL)
(CAADR CL)
ELEMENT))
(RETURN (RPLACD (CADR CL)
(IPLUS (CDADR CL)
NUMBER]
OLDCL])
(DIFFCL
[LAMBDA (L1 L2)
(FOR X IN L1 AS N IS (IDIFFERENCE (CDR X)
(OR (CDR (SASSOC (CAR X)
L2))
0))
WHEN (IGREATERP N 0) COLLECT (CONS (CAR X)
N])
(SUBSETS
[LAMBDA (C N)
(COND
[(EQ 0 N)
(QUOTE ((NIL . 1]
((FOR OLD C ON C ALWAYS (IGREATERP (CAAR C)
N))
NIL)
(T (* GET RID OF NUMBERS AT HEAD
THAT ARE TOO BIG)
(* RETURN NIL WHEN THEY ALL ARE
TO BIG)
(* THE FIRST OF THE LIST IS ALL SUBSETS WITHOUT USING THE
FIRST OF C)
(* THE FIRST ELEMENT OF THE NEW SUBSET IS THE FIRST OF THE
OLD ;TRY UP TO HOW MANY ON THE OLD ;I IS THE NUMBER OF TIMES
IT OCCURS AND II IS THE AMOUNT TAKEN ;IT IS UPPER-BOUNDED BY
N)
(* TRY EVERY SUBSET OF THE REST
ADDING UP TO N-II)
(* X MUST NOT BE NIL ;THE FACTOR IS THE NUMBER OF WAYS OF
TAKING I ELEMENTS OUT OF THE (CDAR C) ELEMENT AVAILABLE)
(FOR I FROM 1 TO (CDAR C) AS II FROM (CAAR C) TO N
BY (CAAR C) AS X IS (SUBSETS (CDR C)
(IDIFFERENCE N II))
WHEN X AS FACTOR IS (TAKEN (CDAR C)
I)
FOR
OLD X ON X RCOLLECT FIRST (SUBSETS (CDR C)
N)
(CONS (CONS (CONS (CAAR C)
I)
(CAAR X))
(ITIMES FACTOR (CDAR X])
(PCYCLEINDEX
[LAMBDA (CYCLES NODES)
(PROG (INDEX)
[FOR CYCLE IN CYCLES AS CYCLESIZE IS
(SIZE (INTERSECT (fetch SETOF of CYCLE)
NODES))
DO (SETQ INDEX (INSERTCL 1 CYCLESIZE INDEX (QUOTE ILESSP]
(RETURN (COND
([NOT (EQP 0 (SETQ CYCLES
(IDIFFERENCE (SIZE NODES)
(FOR X IN INDEX
SUM (ITIMES (CAR X)
(CDR X]
(CONS (CONS 1 CYCLES)
INDEX))
(T INDEX])
(CYCLEINDEX
[LAMBDA (GROUP NODES)
(PROG (INDEX)
[FOR PERM IN GROUP
AS DUPLICITY IS [COND
((OR (NOT (fetch ORDEROF of PERM))
(EQ INPUTMODE (QUOTE FUNCTION)))
1)
(T (TWICE (LENGTH (fetch ORDEROF of PERM]
DO (SETQ INDEX (INSERTCL DUPLICITY (PCYCLEINDEX (fetch CYCLESOF
of PERM)
NODES)
INDEX
(FUNCTION (LAMBDA (X Y)
(AND (NOT (EQUAL X Y))
(ORDERED X Y]
(RETURN (CONS (CONS (LIST (CONS 1 (SIZE NODES)))
1)
INDEX])
(LFROMCL
[LAMBDA (CL N)
(SETQ CL (SORT (MAPCAR CL (QUOTE CDR))
(QUOTE ILESSP)))
(COND
([NOT (ZEROP (SETQ N (IDIFFERENCE N (sum X for X in CL]
(INSERT N CL (QUOTE ILESSP)))
(T CL])
(POLYA
[LAMBDA (NODES GROUP SUBLIST)
(PROG (D C NEWGROUP)
(SETQ SUBLIST (LFROMCL SUBLIST (SIZE NODES)))
(SETQ NEWGROUP (CYCLEINDEX GROUP NODES))
(SETQ C (FOR PERM IN NEWGROUP SUM (CDR PERM)))
L1 [COND
((NULL (CDR SUBLIST))
(RETURN (IQUOTIENT (FOR X IN NEWGROUP SUM (CDR X))
C]
(SETQ GROUP NEWGROUP)
(SETQ NEWGROUP NIL)
[FOR X IN GROUP FOR S IN (SUBSETS (CAR X)
(CAR SUBLIST))
AS CYCLEFT IS (DIFFCL (CAR X)
(CAR S))
AS FACTOR IS (ITIMES (CDR X)
(CDR S))
DO (SETQ NEWGROUP (INSERTCL FACTOR CYCLEFT NEWGROUP
(FUNCTION (LAMBDA (X Y)
(AND (NOT (EQUAL X Y))
(ORDERED X Y]
(SETQ SUBLIST (CDR SUBLIST))
(GO L1])
(INSERT
[LAMBDA (ITEM LST CMPR)
(COND
((OR (NULL LST)
(APPLY* CMPR ITEM (CAR LST)))
(CONS ITEM LST))
(T (FRPLACD LST (INSERT ITEM (CDR LST CMPR])
(ORDERED
[LAMBDA (X Y)
(COND
((NLISTP X)
(ALPHORDER X Y))
((NLISTP Y)
NIL)
((EQUAL (CAR X)
(CAR Y))
(ORDERED (CDR X)
(CDR Y)))
(T (ORDERED (CAR X)
(CAR Y])
(SLTPSANDPINVS
[LAMBDA (S P)
(* This isn't working so I took it out
(PROG ((PS (NULLSET)) (PINVS (NULLSET)) I)
(on old P bind ((I← (LARGESTELT))) do
(COND ((CONTAINED I S) (SETQ PS
(UNIONSET PS (CAR P))))) (COND
((CONTAINED (CAR P) S) (SETQ PINVS
(UNIONSET PINVS I)))) (SETQ I (NEXTSMALLESTELT I)))
(SETQ I (LARGESTELT)) LP (COND
((CONTAINED I S) (COND ((OR (AND PS
(NOT (CONTAINED I PS))) (AND PINVS
(NOT (CONTAINED I PINVS)))) (RETURN))))
(T (COND ((NULL PS)) ((CONTAINED I PS)
(* PS IS BIGGER, MAKE SURE THAT COMPARES ARE OK)
(COND (PINVS (SETQ PS)) (T (RETURN T)))))
(COND ((NULL PINVS)) ((CONTAINED I PINVS)
(* PINVS IS BIGGER, MAKE SURE THAT COMPARES ARE OK)
(COND (PS (SETQ PINFS)) (T (RETURN T)))))))
(COND ((ELTLESSP (SETQ I (NEXTSMALLESTELT I)) S)
(RETURN (OR (NULL PS) (NULL PINVS)
(QUOTE EQL)))) (T (GO LP)))))
(PROG (I R NR XI LARGERTHANXI)
(SETQ R (SETQ NR (NULLSET)))
[SETQ LARGERTHANXI (ALLLARGERELTS (SETQ XI (FIRST S]
(SETQ I (LARGESTELT))
LOOP(COND
[(CONTAINED I S)
(COND
[(CONTAINED (CAR P)
S)
(* S AND PS AGREEE, CHECK PINVS I IN S SO CAN ADD
(CAR P) TO R)
(SETQ R (UNIONSET (CAR P)
S))
(COND
((CONTAINED (SETQ XI (FIRST (DISJOINTDIFF S R)))
R)
(RETURN (SLTPS I S P)))
((AND (CONTAINED (SETQ LARGERTHANXI (DIFF (ALLLARGERELTS
XI)
S))
NR)
(CONTAINED XI NR))
(RETURN]
(T (RETURN]
((CONTAINED (CAR P)
S)
(GO INVERSEONLY))
((AND (CONTAINED XI (SETQ NR (UNIONSET (CAR P)
NR)))
(CONTAINED LARGERTHANXI NR))
(RETURN)))
[COND
([OR (ELTLESSP (SETQ I (NEXTSMALLESTELT I))
S)
(NULL (SETQ P (CDR P]
(RETURN (QUOTE EQL]
(GO LOOP)
INVERSEONLY
(SETQ NR (UNIONSET I NR))
LOOP2
(COND
((AND (CONTAINED XI NR)
(CONTAINED LARGERTHANXI NR))
(RETURN)))
[COND
((EQ NIL (SETQ P (CDR P)))
(RETURN (QUOTE EQL]
(SETQ I (NEXTSMALLESTELT I))
[COND
((CONTAINED I S)
(SETQ R (UNION I R))
(COND
((CONTAINED (SETQ X1 (FIRST (DISJOINTDIFF S R)))
R)
(RETURN T)))
(SETQ LARGERTHANXI (DIFF (ALLLARGERELTS XI)
S]
(GO LOOP2])
)
(DEFINEQ
(MLG
[LAMBDA (NODES GROUP LABELS)
(FOR X IN (MANYLABELGRAPHTOP (LST.BINARY NODES)
(LST.BINARYG GROUP)
LABELS)
DO (FOR Y IN (CDR X) DO (PRIN1 (CAR Y))
(PRIN1 (BINARY.LST (CDR Y)))
(SPACES 10))
[COND
((LISTP (CAR (QUOTE PICTURE)))
(FOR I FROM 1 TO (FOR II IN PICTURE MAXIMUM (CADR II))
DO (TERPRI)
(FOR P IN PICTURE WHEN (EQ I (CADR P))
AS ELT IS (LST.BINARY (CAR P)) AS Y IS X
DO (PROG NIL
(COND
((NOT (NUMBERP (CAR P)))
(GO L2)))
(TAB (CDDR P))
L1 [COND
((NULL (SETQ Y (CDR Y)))
(PRIN1 (QUOTE ?)))
((DISJOINT ELT (CDAR Y))
(GO L1))
(T (PRIN1 (CAAR Y]
(GO L3)
L2 (PRIN1 (CAR P))
L3]
(TERPRI)
(PRIN1 (QUOTE "REMAINING GROUP ="))
(TAB 10100)
(PRINT (BINARY.LSTG (CAR X])
(ORBIT1
[LAMBDA (NODES GROUP)
(PROG (CLASS)
(SETQ CLASS (FIRST NODES))
(FOR OLD GROUP ON GROUP FOR PERM ON (fetch CYCLESOF
of (CAR GROUP))
AS CYCLE IS (fetch SETOF of (CAR PERM))
WHEN (NOT (DISJOINT CYCLE CLASS)) DO (SETQ CLASS (UNIONSET CYCLE
CLASS)))
(RETURN (INTERSECT CLASS NODES])
(REDUCEGROUP
[LAMBDA (GROUP NODES)
(FOR OLD GROUP ON GROUP WHEN (FOR PERM ON (fetch CYCLESOF
of (CAR GROUP))
AS CYCLE IS (fetch SETOF
of (CAR PERM))
AS X IS (INTERSECT NODES CYCLE)
ALWAYS (OR (EMPTY X)
(EQSET X CYCLE)))
COLLECT (CAR GROUP])
(COMB
[LAMBDA (NODES NUMBER)
(COND
((EQP 0 NUMBER)
(LIST (NULLSET)))
((EMPTY NODES)
NIL)
((EQ NUMBER 1)
(LISTELT NODES))
(T (FOR FN IS (FIRST NODES) AS OLD NODES IS (REST NODES) AS NN
FROM (SIZE NODES) TO NUMBER BY -1 FOR X IN (COMB NODES
(SUB1 NUMBER))
RCOLLECT (UNIONSET FN X])
(MANYLABELGRAPHTOP
[LAMBDA (NODES GROUP LABELS)
(PROG (X SZNODES)
(SETQ SZNODES (SIZE NODES))
[SORT LABELS (FUNCTION (LAMBDA (X Y)
(ILESSP (CDR X)
(CDR Y]
(SETQ X (POLYA NODES GROUP LABELS))
[PRINT (CONS X (QUOTE (POSSIBLE SUBSTITUTION (S]
[COND
((IGREATERP X 1111101000)
(RETURN (PROGN (PRINT (QUOTE (THIS IS TOO MANY TO COMPUTE)))
NIL]
(SETQ X (MANYLABELGRAPH NODES GROUP LABELS))
[PRINT (CONS (LENGTH X)
(QUOTE (ACTUAL SUBSTITUTIONS MADE]
(RETURN X])
(MANYLABELGRAPH
[LAMBDA (NODES GROUP LABELS)
(COND
((FOR OLD LABELS ON LABELS ALWAYS (EQP 0 (CDAR LABELS)))
NIL)
[(NULL (CDR LABELS))
(FOR X IN (LABELGRAPH NODES GROUP (CDAR LABELS))
RCOLLECT (LIST (CDR X)
(CONS (CAAR LABELS)
(CAR X]
(T (FOR NODGRP IN (LABELGRAPH NODES GROUP (CDAR LABELS)) FOR LABELING
IN (MANYLABELGRAPH (DIFF NODES (CAR NODGRP))
(CDR NODGRP)
(CDR LABELS))
RCOLLECT (CONS (CAR LABELING)
(CONS (CONS (CAAR LABELS)
(CAR NODGRP))
(CDR LABELING])
(LABELCLASS
[LAMBDA (CLASS GROUP NUMBER)
(COND
[(IGREATERP (TWICE NUMBER)
(SIZE CLASS))
(FOR X IN (LABELCLASS CLASS GROUP (IDIFFERENCE (SIZE CLASS)
NUMBER))
RCOLLECT (CONS (DIFF CLASS (CAR X))
(CDR X]
((ZEROP NUMBER)
(LIST (CONS (NULLSET)
GROUP)))
[(EQ NUMBER 1)
(LIST (CONS (SETQ CLASS (FIRST CLASS))
(REDUCEGROUP GROUP CLASS]
(T (LABELGENCLASS CLASS GROUP NUMBER])
(LABELGENCLASS
[LAMBDA (CLASS GROUP NUMBER)
(* Making use of SIMS, compute candidate labellings and
check if they are CANONICAL)
(for X in (LABELORBITS (ORBITS CLASS GROUP)
NUMBER)
when (CANONICAL X GROUP) collect (CONS X (REDUCEGROUP GROUP X])
(LABELORBITS
[LAMBDA (ORBITS NUMBER)
(* ORBITS ARE THE "ORBBITS" OF SIMS RESULT -
I.E. THE ORBITS OF THE STABELIZER SUBGROUPS)
(PROG (LORESULT)
(LO1 ORBITS NUMBER (NULLSET))
(RETURN LORESULT])
(LO1
[LAMBDA (ORBITS NUMBER SET)
(COND
((MINUSP NUMBER) (* CAN'T LABEL NEGATIVE NUMBER
OF THINGS)
NIL)
((ZEROP NUMBER) (* NO MORE TO BE LABELED)
(LOADD SET))
((ILESSP (LENGTH ORBITS)
NUMBER)
(* LENGTH ORBITS IS THE SAME AS THE NUMBER OF THINGS TO BE
LABELLED)
NIL)
[(EQLENGTH ORBITS NUMBER) (* EXACTLY NUMBER ORBITS LEFT)
(* COLLECT THE "FIRST" OF EACH
ORBIT -
THIS IS THE CANDIDATE)
(LOADD (PROG ((RESULT SET))
[FOR X IN ORBITS DO (SETQ RESULT (UNIONSET RESULT
(FIRST X]
(RETURN RESULT]
(T (* TRY LABELLING NUMBER ORBITS
WITHOUT LABELLING THIS ONE)
(LO1 (CDR ORBITS)
NUMBER SET)
(* If you label (FIRST (CAR ORBITS)) then you must label all
of (CAR ORBITS) -
Since s<<ps => p (x) << p (ox); here ox is
(CAR ORBITS), x is (FIRST OX) and if any of ox is on, then x
must be?)
(LO1 (FOR O IN (CDR ORBITS) WHEN (DISJOINT (FIRST O)
(CAR ORBITS))
COLLECT O)
(IDIFFERENCE NUMBER (SIZE (CAR ORBITS)))
(UNIONSET SET (CAR ORBITS])
(LOADD
[LAMBDA (NODES)
(SETQ LORESULT (CONS NODES LORESULT])
(ORBITS
[LAMBDA (NODES GROUP)
(COND
((EMPTY NODES)
NIL)
((NULL GROUP)
(LISTELT NODES))
(T (CONS (ORBIT1 NODES GROUP)
(ORBITS (REST NODES)
(REDUCEGROUP GROUP (FIRST NODES])
(CANONICAL
[LAMBDA (NODES GROUP)
(EVERY GROUP (FUNCTION (LAMBDA (PERM)
(COND
[(NULL (fetch ORDEROF of PERM))
(SLTPS (LARGESTELT)
NODES
(CAR (fetch POWERSOF of PERM]
(T (FOR P IN (fetch POWERSOF of PERM) AS PRED IS (
SLTPSANDPINVS
NODES P)
WHILE (NEQ PRED (QUOTE EQL)) ALWAYS PRED])
(SLTPS
[LAMBDA (I S P)
(PROG NIL
L1 [COND
[(NOT (CONTAINED I S))
(COND
((CONTAINED (CAR P)
S)
(RETURN T))
(T (SETQ P (CDR P))
(SETQ I (NEXTSMALLESTELT I]
((NOT (CONTAINED (CAR P)
S))
(RETURN NIL))
((ELTLESSP (SETQ I (NEXTSMALLESTELT I))
S)
(RETURN (QUOTE EQL)))
(T (SETQ P (CDR P]
(GO L1])
)
(RPAQQ INPUTMODE FUNCTION)
STOP